home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / intrfc62.zip / BLOCKS.PAS < prev    next >
Pascal/Delphi Source File  |  1991-05-05  |  7KB  |  313 lines
  1. unit blocks;
  2.  
  3. interface
  4.  
  5. uses nametype;
  6.  
  7. type
  8.   entry_pt_ptr = ^entry_pt_rec;
  9.   entry_pt_rec = record
  10.     w1 : word;
  11.     flags : obj_flags;
  12.     b1 : byte;
  13.     code_block, offset : word;
  14.   end;
  15.  
  16.   block_ptr = ^block_rec;
  17.   block_rec = record
  18.     w1,size : word;
  19.     relocbytes,owner : word;
  20.   end;
  21.  
  22.   const_block_ptr = ^const_block_rec;
  23.   const_block_rec = record
  24.     w1,size : word;
  25.     relocbytes,obj_ofs : word;
  26.   end;
  27.  
  28.   vmt_block_ptr = ^vmt_block_rec;
  29.   vmt_block_rec = record
  30.     unitnum,rtype : byte;
  31.     entrynum,w3,vmt_ofs : word;
  32.   end;
  33.  
  34.   unit_block_ptr = ^unit_block_rec;
  35.   unit_block_rec = record
  36.     w1 : word;
  37.     name : string;
  38.   end;
  39.  
  40.   dll_block_ptr = ^dll_block_rec;
  41.   dll_block_rec = record
  42.     w1,w2 : word;
  43.     name : string;
  44.   end;
  45.  
  46.   debug_block_ptr = ^debug_block_rec;
  47.   debug_block_rec = record
  48.     obj_ofs, w2, w3, startline, len : word;
  49.     bytes_per_line : array[1..1] of byte;
  50.   end;
  51.  
  52. procedure print_entries;
  53. procedure print_code_blocks;
  54. procedure print_const_blocks;
  55. procedure print_var_blocks;
  56. procedure print_dll_blocks;
  57. procedure print_unit_blocks;
  58.  
  59. function unit_name(ofs:word):string;
  60. function dll_name(ofs:word):string;
  61.  
  62. procedure write_code_block_name(debug_ofs : word);
  63. procedure write_const_block_name(info_ofs : word);
  64.  
  65. procedure add_referenced_units;
  66.  
  67. implementation
  68.  
  69. uses dump,util,globals,head,loader,namelist,reloc;
  70.  
  71. procedure print_entries;
  72. var
  73.   block:entry_pt_ptr;
  74.   base,limit,ofs : word;
  75.   dll : dll_block_ptr;
  76. begin
  77.   writeln;
  78.   writeln('Entry records');
  79.   base  := header^.ofs_entry_pts;
  80.   limit := header^.ofs_code_blocks;
  81.   if base>=limit then
  82.     writeln('(none)')
  83.   else
  84.   begin
  85.     writeln('    Proc    Code block:offset');
  86.     ofs := 0;
  87.     while base+ofs<limit do
  88.     begin
  89.       block := add_offset(buffer,base+ofs);
  90.       with block^ do
  91.       begin
  92.         write(hexword2(ofs):8);
  93.         if from_dll in flags then
  94.         begin
  95.           dll := add_offset(buffer,header^.ofs_dll_list+code_block);
  96.           write(dll^.name:12,' ');
  97.           if by_name in flags then
  98.           begin
  99.             dll := add_offset(buffer,header^.ofs_dll_list+offset);
  100.             write('Name ',dll^.name:8);
  101.           end
  102.           else
  103.             write('Index ',offset:7);
  104.         end
  105.         else
  106.           write(hexword2(block^.code_block):12,':',hexword(block^.offset));
  107.         if w1 <> 0 then
  108.           write('w1 = ',hexword(w1));
  109.         if b1 <> 0 then
  110.           write('b1 = ',hexbyte(b1));
  111.         writeln;
  112.       end;
  113.       inc(ofs,sizeof(block^));
  114.     end;
  115.   end;
  116. end;
  117.  
  118. procedure write_code_block_name(debug_ofs : word);
  119. var
  120.   debug : debug_block_ptr;
  121.   obj : obj_ptr;
  122.   info : func_info_ptr;
  123.   parent_info : word;
  124.   parent_obj : obj_ptr;
  125. begin
  126.   if debug_ofs = $FFFF then
  127.     exit;
  128.   debug := add_offset(buffer,header^.ofs_line_lengths+debug_ofs);
  129.   if debug^.obj_ofs = 0 then
  130.     write('Startup code')
  131.   else
  132.   begin
  133.     obj := add_offset(buffer,debug^.obj_ofs);
  134.     if obj^.obj_type = proc_id then
  135.     begin
  136.       info := add_offset(obj,4+length(obj^.name));
  137.       parent_info := info^.parent_ofs;
  138.       if parent_info <> 0 then
  139.       begin
  140.         parent_obj := find_type(unit_list[1],parent_info);
  141.         if parent_obj <> nil then
  142.           write(parent_obj^.name,'.')
  143.         else
  144.           write('obj',hexword(parent_info),'.');
  145.       end;
  146.     end;
  147.     write(obj^.name);
  148.   end;
  149. end;
  150.  
  151. procedure write_const_block_name(info_ofs : word);
  152. var
  153.   obj : obj_ptr;
  154. begin
  155.   if info_ofs = 0 then
  156.     exit;
  157.   obj := find_type(unit_list[1],info_ofs);
  158.   if obj <> nil then
  159.     write(obj^.name)
  160.   else
  161.     write('obj',hexword(info_ofs));
  162. end;
  163.  
  164. procedure print_blocks(blocktype:string; base,limit:word);
  165. var
  166.   ofs : word;
  167.   block : block_ptr;
  168. begin
  169.   writeln;
  170.   writeln(blocktype,' blocks');
  171.   if base >= limit then
  172.     writeln('(none)')
  173.   else
  174.   begin
  175.     writeln('Blocknum   Bytes  Relocrecs   Owner');
  176.     ofs := 0;
  177.     while base+ofs < limit do
  178.     begin
  179.       block := add_offset(buffer,base+ofs);
  180.       with block^ do
  181.       begin
  182.         write(hexword2(ofs):8,hexword2(size):8,hexword2(relocbytes):8,
  183.                   hexword2(owner):8,' ');
  184.         if blocktype = 'Code' then
  185.           write_code_block_name(owner)
  186.         else if blocktype = 'Const' then
  187.           write_const_block_name(owner);
  188.         if w1 <> 0 then
  189.           write(' w1 = ',hexword(w1));
  190.         writeln;
  191.       end;
  192.       inc(ofs,sizeof(block_rec));
  193.     end;
  194.   end;
  195. end;
  196.  
  197. procedure print_code_blocks;
  198. var
  199.   base,limit:word;
  200. begin
  201.   base := header^.ofs_code_blocks;
  202.   limit := header^.ofs_const_blocks;
  203.   print_blocks('Code',base,limit);
  204. end;
  205.  
  206. procedure print_const_blocks;
  207. var
  208.   base,limit:word;
  209. begin
  210.   base := header^.ofs_const_blocks;
  211.   limit := header^.ofs_var_blocks;
  212.   print_blocks('Const',base,limit);
  213. end;
  214.  
  215. procedure print_var_blocks;
  216. var
  217.   base,limit:word;
  218. begin
  219.   base := header^.ofs_var_blocks;
  220.   limit := header^.ofs_dll_list;
  221.   print_blocks('Var',base,limit);
  222. end;
  223.  
  224. procedure print_dll_blocks;
  225. var
  226.   base,ofs,limit:word;
  227.   block : dll_block_ptr;
  228. begin
  229.   writeln;
  230.   writeln('DLL name list');
  231.   base := header^.ofs_dll_list;
  232.   limit := header^.ofs_unit_list;
  233.   if base >= limit then
  234.     writeln('(none)')
  235.   else
  236.   begin
  237.     writeln(' Offset    Name');
  238.     ofs := 0;
  239.     while base+ofs < limit do
  240.     begin
  241.       block := add_offset(buffer,base+ofs);
  242.       with block^ do
  243.       begin
  244.         write(hexword2(ofs):8,'  ',name);
  245.         if w1 <> 0 then
  246.           write(' w1= ',hexword(w1));
  247.         if w2 <> 0 then
  248.           write(' w2= ',hexword(w2));
  249.         writeln;
  250.         ofs := ofs + 5 + length(name);
  251.       end;
  252.     end;
  253.   end;
  254. end;
  255.  
  256. procedure print_unit_blocks;
  257. var
  258.   base,ofs,limit:word;
  259.   block : unit_block_ptr;
  260. begin
  261.   writeln;
  262.   writeln('Unit list');
  263.   base := header^.ofs_unit_list;
  264.   limit := header^.ofs_src_name;
  265.   if base >= limit then
  266.     writeln('(none)')
  267.   else
  268.   begin
  269.     writeln(' Offset    Name');
  270.     ofs := 0;
  271.     while base+ofs < limit do
  272.     begin
  273.       block := add_offset(buffer,base+ofs);
  274.       with block^ do
  275.       begin
  276.         write(hexword2(ofs):8,'  ',name);
  277.         if w1 <> 0 then
  278.           write(' w1 = ',hexword(w1));
  279.         writeln;
  280.         ofs := ofs + 3 + length(name);
  281.       end;
  282.     end;
  283.   end;
  284. end;
  285.  
  286. function unit_name(ofs:word):string;
  287. begin
  288.   unit_name := unit_block_ptr(
  289.                 add_offset(buffer,header^.ofs_unit_list+ofs))^.name;
  290. end;
  291.  
  292. function dll_name(ofs:word):string;
  293. begin
  294.   dll_name := dll_block_ptr(
  295.                 add_offset(buffer,header^.ofs_dll_list+ofs))^.name;
  296. end;
  297.  
  298. procedure add_referenced_units;
  299. var
  300.   block : unit_block_ptr;
  301.   ofs   : word;
  302. begin
  303.   ofs := header^.ofs_unit_list;
  304.   while ofs < header^.ofs_src_name do
  305.   begin
  306.     block := add_offset(buffer,ofs);
  307.     add_unit(block^.name,nil);
  308.     ofs := ofs + 3 + length(block^.name);
  309.   end;
  310. end;
  311.  
  312. end.
  313.